home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Utilities / Calc / value.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-24  |  27.1 KB  |  1,334 lines  |  [TEXT/????]
  1. /*
  2.  * Copyright (c) 1992 David I. Bell
  3.  * Permission is granted to use, distribute, or modify this source,
  4.  * provided that this copyright notice remains intact.
  5.  *
  6.  * Generic value manipulation routines.
  7.  */
  8.  
  9. #include "calc.h"
  10. #include "opcodes.h"
  11. #include "func.h"
  12. #include "symbol.h"
  13.  
  14.  
  15. /*
  16.  * Free a value and set its type to undefined.
  17.  */
  18. void
  19. freevalue(vp)
  20.     register VALUE *vp;    /* value to be freed */
  21. {
  22.     int type;        /* type of value being freed */
  23.  
  24.     type = vp->v_type;
  25.     vp->v_type = V_NULL;
  26.     switch (type) {
  27.         case V_NULL:
  28.         case V_ADDR:
  29.         case V_FILE:
  30.             break;
  31.         case V_STR:
  32.             if (vp->v_subtype == V_STRALLOC)
  33.                 free(vp->v_str);
  34.             break;
  35.         case V_NUM:
  36.             qfree(vp->v_num);
  37.             break;
  38.         case V_COM:
  39.             comfree(vp->v_com);
  40.             break;
  41.         case V_MAT:
  42.             matfree(vp->v_mat);
  43.             break;
  44.         case V_LIST:
  45.             listfree(vp->v_list);
  46.             break;
  47.         case V_OBJ:
  48.             objfree(vp->v_obj);
  49.             break;
  50.         default:
  51.             error("Freeing unknown value type");
  52.     }
  53. }
  54.  
  55.  
  56. /*
  57.  * Copy a value from one location to another.
  58.  * This overwrites the specified new value without checking it.
  59.  */
  60. void
  61. copyvalue(oldvp, newvp)
  62.     register VALUE *oldvp;        /* value to be copied from */
  63.     register VALUE *newvp;        /* value to be copied into */
  64. {
  65.     newvp->v_type = V_NULL;
  66.     switch (oldvp->v_type) {
  67.         case V_NULL:
  68.             break;
  69.         case V_FILE:
  70.             newvp->v_file = oldvp->v_file;
  71.             break;
  72.         case V_NUM:
  73.             newvp->v_num = qlink(oldvp->v_num);
  74.             break;
  75.         case V_COM:
  76.             newvp->v_com = clink(oldvp->v_com);
  77.             break;
  78.         case V_STR:
  79.             newvp->v_str = oldvp->v_str;
  80.             if (oldvp->v_subtype == V_STRALLOC) {
  81.                 newvp->v_str = (char *)malloc(strlen(oldvp->v_str) + 1);
  82.                 if (newvp->v_str == NULL)
  83.                     error("Cannot get memory for string copy");
  84.                 strcpy(newvp->v_str, oldvp->v_str);
  85.             }
  86.             break;
  87.         case V_MAT:
  88.             newvp->v_mat = matcopy(oldvp->v_mat);
  89.             break;
  90.         case V_LIST:
  91.             newvp->v_list = listcopy(oldvp->v_list);
  92.             break;
  93.         case V_ADDR:
  94.             newvp->v_addr = oldvp->v_addr;
  95.             break;
  96.         case V_OBJ:
  97.             newvp->v_obj = objcopy(oldvp->v_obj);
  98.             break;
  99.         default:
  100.             error("Copying unknown value type");
  101.     }
  102.     newvp->v_subtype = oldvp->v_subtype;
  103.     newvp->v_type = oldvp->v_type;
  104.  
  105. }
  106.  
  107.  
  108. /*
  109.  * Negate an arbitrary value.
  110.  * Result is placed in the indicated location.
  111.  */
  112. void
  113. negvalue(vp, vres)
  114.     VALUE *vp, *vres;
  115. {
  116.     vres->v_type = V_NULL;
  117.     switch (vp->v_type) {
  118.         case V_NUM:
  119.             vres->v_num = qneg(vp->v_num);
  120.             vres->v_type = V_NUM;
  121.             return;
  122.         case V_COM:
  123.             vres->v_com = cneg(vp->v_com);
  124.             vres->v_type = V_COM;
  125.             return;
  126.         case V_MAT:
  127.             vres->v_mat = matneg(vp->v_mat);
  128.             vres->v_type = V_MAT;
  129.             return;
  130.         case V_OBJ:
  131.             *vres = objcall(OBJ_NEG, vp);
  132.             return;
  133.         default:
  134.             error("Illegal value for negation");
  135.     }
  136. }
  137.  
  138.  
  139. /*
  140.  * Add two arbitrary values together.
  141.  * Result is placed in the indicated location.
  142.  */
  143. void
  144. addvalue(v1, v2, vres)
  145.     VALUE *v1, *v2, *vres;
  146. {
  147.     COMPLEX *c;
  148.  
  149.     vres->v_type = V_NULL;
  150.     switch (TWOVAL(v1->v_type, v2->v_type)) {
  151.         case TWOVAL(V_NUM, V_NUM):
  152.             vres->v_num = qadd(v1->v_num, v2->v_num);
  153.             vres->v_type = V_NUM;
  154.             return;
  155.         case TWOVAL(V_COM, V_NUM):
  156.             vres->v_com = caddq(v1->v_com, v2->v_num);
  157.             vres->v_type = V_COM;
  158.             return;
  159.         case TWOVAL(V_NUM, V_COM):
  160.             vres->v_com = caddq(v2->v_com, v1->v_num);
  161.             vres->v_type = V_COM;
  162.             return;
  163.         case TWOVAL(V_COM, V_COM):
  164.             vres->v_com = cadd(v1->v_com, v2->v_com);
  165.             vres->v_type = V_COM;
  166.             c = vres->v_com;
  167.             if (!cisreal(c))
  168.                 return;
  169.             vres->v_num = qlink(c->real);
  170.             vres->v_type = V_NUM;
  171.             comfree(c);
  172.             return;
  173.         case TWOVAL(V_MAT, V_MAT):
  174.             vres->v_mat = matadd(v1->v_mat, v2->v_mat);
  175.             vres->v_type = V_MAT;
  176.             return;
  177.         default:
  178.             if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
  179.                 error("Non-compatible values for add");
  180.             *vres = objcall(OBJ_ADD, v1, v2);
  181.             return;
  182.     }
  183. }
  184.  
  185.  
  186. /*
  187.  * Subtract one arbitrary value from another one.
  188.  * Result is placed in the indicated location.
  189.  */
  190. void
  191. subvalue(v1, v2, vres)
  192.     VALUE *v1, *v2, *vres;
  193. {
  194.     COMPLEX *c;
  195.  
  196.     vres->v_type = V_NULL;
  197.     switch (TWOVAL(v1->v_type, v2->v_type)) {
  198.         case TWOVAL(V_NUM, V_NUM):
  199.             vres->v_num = qsub(v1->v_num, v2->v_num);
  200.             vres->v_type = V_NUM;
  201.             return;
  202.         case TWOVAL(V_COM, V_NUM):
  203.             vres->v_com = csubq(v1->v_com, v2->v_num);
  204.             vres->v_type = V_COM;
  205.             return;
  206.         case TWOVAL(V_NUM, V_COM):
  207.             c = csubq(v2->v_com, v1->v_num);
  208.             vres->v_com = cneg(c);
  209.             comfree(c);
  210.             vres->v_type = V_COM;
  211.             return;
  212.         case TWOVAL(V_COM, V_COM):
  213.             vres->v_com = csub(v1->v_com, v2->v_com);
  214.             vres->v_type = V_COM;
  215.             c = vres->v_com;
  216.             if (!cisreal(c))
  217.                 return;
  218.             vres->v_num = qlink(c->real);
  219.             vres->v_type = V_NUM;
  220.             comfree(c);
  221.             return;
  222.         case TWOVAL(V_MAT, V_MAT):
  223.             vres->v_mat = matsub(v1->v_mat, v2->v_mat);
  224.             vres->v_type = V_MAT;
  225.             return;
  226.         default:
  227.             if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
  228.                 error("Non-compatible values for subtract");
  229.             *vres = objcall(OBJ_SUB, v1, v2);
  230.             return;
  231.     }
  232. }
  233.  
  234.  
  235. /*
  236.  * Multiply two arbitrary values together.
  237.  * Result is placed in the indicated location.
  238.  */
  239. void
  240. mulvalue(v1, v2, vres)
  241.     VALUE *v1, *v2, *vres;
  242. {
  243.     COMPLEX *c;
  244.  
  245.     vres->v_type = V_NULL;
  246.     switch (TWOVAL(v1->v_type, v2->v_type)) {
  247.         case TWOVAL(V_NUM, V_NUM):
  248.             vres->v_num = qmul(v1->v_num, v2->v_num);
  249.             vres->v_type = V_NUM;
  250.             return;
  251.         case TWOVAL(V_COM, V_NUM):
  252.             vres->v_com = cmulq(v1->v_com, v2->v_num);
  253.             vres->v_type = V_COM;
  254.             break;
  255.         case TWOVAL(V_NUM, V_COM):
  256.             vres->v_com = cmulq(v2->v_com, v1->v_num);
  257.             vres->v_type = V_COM;
  258.             break;
  259.         case TWOVAL(V_COM, V_COM):
  260.             vres->v_com = cmul(v1->v_com, v2->v_com);
  261.             vres->v_type = V_COM;
  262.             break;
  263.         case TWOVAL(V_MAT, V_MAT):
  264.             vres->v_mat = matmul(v1->v_mat, v2->v_mat);
  265.             vres->v_type = V_MAT;
  266.             return;
  267.         case TWOVAL(V_MAT, V_NUM):
  268.         case TWOVAL(V_MAT, V_COM):
  269.             vres->v_mat = matmulval(v1->v_mat, v2);
  270.             vres->v_type = V_MAT;
  271.             return;
  272.         case TWOVAL(V_NUM, V_MAT):
  273.         case TWOVAL(V_COM, V_MAT):
  274.             vres->v_mat = matmulval(v2->v_mat, v1);
  275.             vres->v_type = V_MAT;
  276.             return;
  277.         default:
  278.             if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
  279.                 error("Non-compatible values for multiply");
  280.             *vres = objcall(OBJ_MUL, v1, v2);
  281.             return;
  282.     }
  283.     c = vres->v_com;
  284.     if (cisreal(c)) {
  285.         vres->v_num = qlink(c->real);
  286.         vres->v_type = V_NUM;
  287.         comfree(c);
  288.     }
  289. }
  290.  
  291.  
  292. /*
  293.  * Square an arbitrary value.
  294.  * Result is placed in the indicated location.
  295.  */
  296. void
  297. squarevalue(vp, vres)
  298.     VALUE *vp, *vres;
  299. {
  300.     COMPLEX *c;
  301.  
  302.     vres->v_type = V_NULL;
  303.     switch (vp->v_type) {
  304.         case V_NUM:
  305.             vres->v_num = qsquare(vp->v_num);
  306.             vres->v_type = V_NUM;
  307.             return;
  308.         case V_COM:
  309.             vres->v_com = csquare(vp->v_com);
  310.             vres->v_type = V_COM;
  311.             c = vres->v_com;
  312.             if (!cisreal(c))
  313.                 return;
  314.             vres->v_num = qlink(c->real);
  315.             vres->v_type = V_NUM;
  316.             comfree(c);
  317.             return;
  318.         case V_MAT:
  319.             vres->v_mat = matsquare(vp->v_mat);
  320.             vres->v_type = V_MAT;
  321.             return;
  322.         case V_OBJ:
  323.             *vres = objcall(OBJ_SQUARE, vp);
  324.             return;
  325.         default:
  326.             error("Illegal value for squaring");
  327.     }
  328. }
  329.  
  330.  
  331. /*
  332.  * Invert an arbitrary value.
  333.  * Result is placed in the indicated location.
  334.  */
  335. void
  336. invertvalue(vp, vres)
  337.     VALUE *vp, *vres;
  338. {
  339.     vres->v_type = V_NULL;
  340.     switch (vp->v_type) {
  341.         case V_NUM:
  342.             vres->v_num = qinv(vp->v_num);
  343.             vres->v_type = V_NUM;
  344.             return;
  345.         case V_COM:
  346.             vres->v_com = cinv(vp->v_com);
  347.             vres->v_type = V_COM;
  348.             return;
  349.         case V_MAT:
  350.             vres->v_mat = matinv(vp->v_mat);
  351.             vres->v_type = V_MAT;
  352.             return;
  353.         case V_OBJ:
  354.             *vres = objcall(OBJ_INV, vp);
  355.             return;
  356.         default:
  357.             error("Illegal value for inverting");
  358.     }
  359. }
  360.  
  361.  
  362. /*
  363.  * Round an arbitrary value to the specified number of decimal places.
  364.  * Result is placed in the indicated location.
  365.  */
  366. void
  367. roundvalue(v1, v2, vres)
  368.     VALUE *v1, *v2, *vres;
  369. {
  370.     long places;
  371.     NUMBER *q;
  372.     COMPLEX *c;
  373.  
  374.     switch (v2->v_type) {
  375.         case V_NUM:
  376.             q = v2->v_num;
  377.             if (qisfrac(q) || isbig(q->num))
  378.                 error("Bad number of places for round");
  379.             places = qtoi(q);
  380.             break;
  381.         case V_INT:
  382.             places = v2->v_int;
  383.             break;
  384.         default:
  385.             error("Bad value type for places in round");
  386.     }
  387.     if (places < 0)
  388.         error("Negative number of places in round");
  389.     vres->v_type = V_NULL;
  390.     switch (v1->v_type) {
  391.         case V_NUM:
  392.             if (qisint(v1->v_num))
  393.                 vres->v_num = qlink(v1->v_num);
  394.             else
  395.                 vres->v_num = qround(v1->v_num, places);
  396.             vres->v_type = V_NUM;
  397.             return;
  398.         case V_COM:
  399.             if (cisint(v1->v_com)) {
  400.                 vres->v_com = clink(v1->v_com);
  401.                 vres->v_type = V_COM;
  402.                 return;
  403.             }
  404.             vres->v_com = cround(v1->v_com, places);
  405.             vres->v_type = V_COM;
  406.             c = vres->v_com;
  407.             if (cisreal(c)) {
  408.                 vres->v_num = qlink(c->real);
  409.                 vres->v_type = V_NUM;
  410.                 comfree(c);
  411.             }
  412.             return;
  413.         case V_MAT:
  414.             vres->v_mat = matround(v1->v_mat, places);
  415.             vres->v_type = V_MAT;
  416.             return;
  417.         case V_OBJ:
  418.             *vres = objcall(OBJ_ROUND, v1, v2);
  419.             return;
  420.         default:
  421.             error("Illegal value for round");
  422.     }
  423. }
  424.  
  425.  
  426. /*
  427.  * Round an arbitrary value to the specified number of binary places.
  428.  * Result is placed in the indicated location.
  429.  */
  430. void
  431. broundvalue(v1, v2, vres)
  432.     VALUE *v1, *v2, *vres;
  433. {
  434.     long places;
  435.     NUMBER *q;
  436.     COMPLEX *c;
  437.  
  438.     switch (v2->v_type) {
  439.         case V_NUM:
  440.             q = v2->v_num;
  441.             if (qisfrac(q) || isbig(q->num))
  442.                 error("Bad number of places for bround");
  443.             places = qtoi(q);
  444.             break;
  445.         case V_INT:
  446.             places = v2->v_int;
  447.             break;
  448.         default:
  449.             error("Bad value type for places in bround");
  450.     }
  451.     if (places < 0)
  452.         error("Negative number of places in bround");
  453.     vres->v_type = V_NULL;
  454.     switch (v1->v_type) {
  455.         case V_NUM:
  456.             if (qisint(v1->v_num))
  457.                 vres->v_num = qlink(v1->v_num);
  458.             else
  459.                 vres->v_num = qbround(v1->v_num, places);
  460.             vres->v_type = V_NUM;
  461.             return;
  462.         case V_COM:
  463.             if (cisint(v1->v_com)) {
  464.                 vres->v_com = clink(v1->v_com);
  465.                 vres->v_type = V_COM;
  466.                 return;
  467.             }
  468.             vres->v_com = cbround(v1->v_com, places);
  469.             vres->v_type = V_COM;
  470.             c = vres->v_com;
  471.             if (cisreal(c)) {
  472.                 vres->v_num = qlink(c->real);
  473.                 vres->v_type = V_NUM;
  474.                 comfree(c);
  475.             }
  476.             return;
  477.         case V_MAT:
  478.             vres->v_mat = matbround(v1->v_mat, places);
  479.             vres->v_type = V_MAT;
  480.             return;
  481.         case V_OBJ:
  482.             *vres = objcall(OBJ_BROUND, v1, v2);
  483.             return;
  484.         default:
  485.             error("Illegal value for bround");
  486.     }
  487. }
  488.  
  489.  
  490. /*
  491.  * Take the integer part of an arbitrary value.
  492.  * Result is placed in the indicated location.
  493.  */
  494. void
  495. intvalue(vp, vres)
  496.     VALUE *vp, *vres;
  497. {
  498.     COMPLEX *c;
  499.  
  500.     vres->v_type = V_NULL;
  501.     switch (vp->v_type) {
  502.         case V_NUM:
  503.             if (qisint(vp->v_num))
  504.                 vres->v_num = qlink(vp->v_num);
  505.             else
  506.                 vres->v_num = qint(vp->v_num);
  507.             vres->v_type = V_NUM;
  508.             return;
  509.         case V_COM:
  510.             if (cisint(vp->v_com)) {
  511.                 vres->v_com = clink(vp->v_com);
  512.                 vres->v_type = V_COM;
  513.                 return;
  514.             }
  515.             vres->v_com = cint(vp->v_com);
  516.             vres->v_type = V_COM;
  517.             c = vres->v_com;
  518.             if (cisreal(c)) {
  519.                 vres->v_num = qlink(c->real);
  520.                 vres->v_type = V_NUM;
  521.                 comfree(c);
  522.             }
  523.             return;
  524.         case V_MAT:
  525.             vres->v_mat = matint(vp->v_mat);
  526.             vres->v_type = V_MAT;
  527.             return;
  528.         case V_OBJ:
  529.             *vres = objcall(OBJ_INT, vp);
  530.             return;
  531.         default:
  532.             error("Illegal value for int");
  533.     }
  534. }
  535.  
  536.  
  537. /*
  538.  * Take the fractional part of an arbitrary value.
  539.  * Result is placed in the indicated location.
  540.  */
  541. void
  542. fracvalue(vp, vres)
  543.     VALUE *vp, *vres;
  544. {
  545.     vres->v_type = V_NULL;
  546.     switch (vp->v_type) {
  547.         case V_NUM:
  548.             if (qisint(vp->v_num))
  549.                 vres->v_num = qlink(&_qzero_);
  550.             else
  551.                 vres->v_num = qfrac(vp->v_num);
  552.             vres->v_type = V_NUM;
  553.             return;
  554.         case V_COM:
  555.             if (cisint(vp->v_com)) {
  556.                 vres->v_num = clink(&_qzero_);
  557.                 vres->v_type = V_NUM;
  558.                 return;
  559.             }
  560.             vres->v_com = cfrac(vp->v_com);
  561.             vres->v_type = V_COM;
  562.             return;
  563.         case V_MAT:
  564.             vres->v_mat = matfrac(vp->v_mat);
  565.             vres->v_type = V_MAT;
  566.             return;
  567.         case V_OBJ:
  568.             *vres = objcall(OBJ_FRAC, vp);
  569.             return;
  570.         default:
  571.             error("Illegal value for frac function");
  572.     }
  573. }
  574.  
  575.  
  576. /*
  577.  * Increment an arbitrary value by one.
  578.  * Result is placed in the indicated location.
  579.  */
  580. void
  581. incvalue(vp, vres)
  582.     VALUE *vp, *vres;
  583. {
  584.     switch (vp->v_type) {
  585.         case V_NUM:
  586.             vres->v_num = qinc(vp->v_num);
  587.             vres->v_type = V_NUM;
  588.             return;
  589.         case V_COM:
  590.             vres->v_com = caddq(vp->v_com, &_qone_);
  591.             vres->v_type = V_COM;
  592.             return;
  593.         case V_OBJ:
  594.             *vres = objcall(OBJ_INC, vp);
  595.             return;
  596.         default:
  597.             error("Illegal value for incrementing");
  598.     }
  599. }
  600.  
  601.  
  602. /*
  603.  * Decrement an arbitrary value by one.
  604.  * Result is placed in the indicated location.
  605.  */
  606. void
  607. decvalue(vp, vres)
  608.     VALUE *vp, *vres;
  609. {
  610.     switch (vp->v_type) {
  611.         case V_NUM:
  612.             vres->v_num = qdec(vp->v_num);
  613.             vres->v_type = V_NUM;
  614.             return;
  615.         case V_COM:
  616.             vres->v_com = caddq(vp->v_com, &_qnegone_);
  617.             vres->v_type = V_COM;
  618.             return;
  619.         case V_OBJ:
  620.             *vres = objcall(OBJ_DEC, vp);
  621.             return;
  622.         default:
  623.             error("Illegal value for decrementing");
  624.     }
  625. }
  626.  
  627.  
  628. /*
  629.  * Produce the 'conjugate' of an arbitrary value.
  630.  * Result is placed in the indicated location.
  631.  * (Example: complex conjugate.)
  632.  */
  633. void
  634. conjvalue(vp, vres)
  635.     VALUE *vp, *vres;
  636. {
  637.     vres->v_type = V_NULL;
  638.     switch (vp->v_type) {
  639.         case V_NUM:
  640.             vres->v_num = qlink(vp->v_num);
  641.             vres->v_type = V_NUM;
  642.             return;
  643.         case V_COM:
  644.             vres->v_com = comalloc();
  645.             vres->v_com->real = qlink(vp->v_com->real);
  646.             vres->v_com->imag = qneg(vp->v_com->imag);
  647.             vres->v_type = V_COM;
  648.             return;
  649.         case V_MAT:
  650.             vres->v_mat = matconj(vp->v_mat);
  651.             vres->v_type = V_MAT;
  652.             return;
  653.         case V_OBJ:
  654.             *vres = objcall(OBJ_CONJ, vp);
  655.             return;
  656.         default:
  657.             error("Illegal value for conjugation");
  658.     }
  659. }
  660.  
  661.  
  662. /*
  663.  * Take the square root of an arbitrary value within the specified error.
  664.  * Result is placed in the indicated location.
  665.  */
  666. void
  667. sqrtvalue(v1, v2, vres)
  668.     VALUE *v1, *v2, *vres;
  669. {
  670.     NUMBER *q, *tmp;
  671.     COMPLEX *c;
  672.  
  673.     if (v2->v_type != V_NUM)
  674.         error("Non-real epsilon for sqrt");
  675.     q = v2->v_num;
  676.     if (qisneg(q) || qiszero(q))
  677.         error("Illegal epsilon value for sqrt");
  678.     switch (v1->v_type) {
  679.         case V_NUM:
  680.             if (!qisneg(v1->v_num)) {
  681.                 vres->v_num = qsqrt(v1->v_num, q);
  682.                 vres->v_type = V_NUM;
  683.                 return;
  684.             }
  685.             tmp = qneg(v1->v_num);
  686.             c = comalloc();
  687.             c->imag = qsqrt(tmp, q);
  688.             qfree(tmp);
  689.             vres->v_com = c;
  690.             vres->v_type = V_COM;
  691.             return;
  692.         case V_COM:
  693.             vres->v_com = csqrt(v1->v_com, q);
  694.             vres->v_type = V_COM;
  695.             return;
  696.         case V_OBJ:
  697.             *vres = objcall(OBJ_SQRT, v1, v2);
  698.             return;
  699.         default:
  700.             error("Bad value for taking square root");
  701.     }
  702. }
  703.  
  704.  
  705. /*
  706.  * Take the Nth root of an arbitrary value within the specified error.
  707.  * Result is placed in the indicated location.
  708.  */
  709. void
  710. rootvalue(v1, v2, v3, vres)
  711.     VALUE *v1;        /* value to take root of */
  712.     VALUE *v2;        /* value specifying root to take */
  713.     VALUE *v3;        /* value specifying error */
  714.     VALUE *vres;
  715. {
  716.     NUMBER *q1, *q2;
  717.     COMPLEX ctmp;
  718.  
  719.     if ((v2->v_type != V_NUM) || (v3->v_type != V_NUM))
  720.         error("Non-real arguments for root");
  721.     q1 = v2->v_num;
  722.     q2 = v3->v_num;
  723.     if (qisneg(q1) || qiszero(q1) || qisfrac(q1))
  724.         error("Non-positive or non-integral root");
  725.     if (qisneg(q2) || qiszero(q2))
  726.         error("Non-positive epsilon for root");
  727.     switch (v1->v_type) {
  728.         case V_NUM:
  729.             if (!qisneg(v1->v_num) || isodd(q1->num)) {
  730.                 vres->v_num = qroot(v1->v_num, q1, q2);
  731.                 vres->v_type = V_NUM;
  732.                 return;
  733.             }
  734.             ctmp.real = v1->v_num;
  735.             ctmp.imag = &_qzero_;
  736.             vres->v_com = croot(&ctmp, q1, q2);
  737.             vres->v_type = V_COM;
  738.             return;
  739.         case V_COM:
  740.             vres->v_com = croot(v1->v_com, q1, q2);
  741.             vres->v_type = V_COM;
  742.             return;
  743.         case V_OBJ:
  744.             *vres = objcall(OBJ_ROOT, v1, v2, v3);
  745.             return;
  746.         default:
  747.             error("Taking root of bad value");
  748.     }
  749. }
  750.  
  751.  
  752. /*
  753.  * Take the absolute value of an arbitrary value within the specified error.
  754.  * Result is placed in the indicated location.
  755.  */
  756. void
  757. absvalue(v1, v2, vres)
  758.     VALUE *v1, *v2, *vres;
  759. {
  760.     NUMBER *q, *epsilon;
  761.  
  762.     if (v2->v_type != V_NUM)
  763.         error("Bad epsilon type for abs");
  764.     epsilon = v2->v_num;
  765.     if (qiszero(epsilon) || qisneg(epsilon))
  766.         error("Non-positive epsilon for abs");
  767.     switch (v1->v_type) {
  768.         case V_NUM:
  769.             if (qisneg(v1->v_num))
  770.                 q = qneg(v1->v_num);
  771.             else
  772.                 q = qlink(v1->v_num);
  773.             break;
  774.         case V_COM:
  775.             q = qhypot(v1->v_com->real, v1->v_com->imag, epsilon);
  776.             break;
  777.         case V_OBJ:
  778.             *vres = objcall(OBJ_ABS, v1, v2);
  779.             return;
  780.         default:
  781.             error("Illegal value for absolute value");
  782.     }
  783.     vres->v_num = q;
  784.     vres->v_type = V_NUM;
  785. }
  786.  
  787.  
  788. /*
  789.  * Calculate the norm of an arbitrary value.
  790.  * Result is placed in the indicated location.
  791.  * The norm is the square of the absolute value.
  792.  */
  793. void
  794. normvalue(vp, vres)
  795.     VALUE *vp, *vres;
  796. {
  797.     NUMBER *q1, *q2;
  798.  
  799.     vres->v_type = V_NULL;
  800.     switch (vp->v_type) {
  801.         case V_NUM:
  802.             vres->v_num = qsquare(vp->v_num);
  803.             vres->v_type = V_NUM;
  804.             return;
  805.         case V_COM:
  806.             q1 = qsquare(vp->v_com->real);
  807.             q2 = qsquare(vp->v_com->imag);
  808.             vres->v_num = qadd(q1, q2);
  809.             vres->v_type = V_NUM;
  810.             qfree(q1);
  811.             qfree(q2);
  812.             return;
  813.         case V_OBJ:
  814.             *vres = objcall(OBJ_NORM, vp);
  815.             return;
  816.         default:
  817.             error("Illegal value for norm");
  818.     }
  819. }
  820.  
  821.  
  822. /*
  823.  * Shift a value left or right by the specified number of bits.
  824.  * Negative shift value means shift the direction opposite the selected dir.
  825.  * Right shifts are defined to lose bits off the low end of the number.
  826.  * Result is placed in the indicated location.
  827.  */
  828. void
  829. shiftvalue(v1, v2, rightshift, vres)
  830.     VALUE *v1, *v2, *vres;
  831.     BOOL rightshift;    /* TRUE if shift right instead of left */
  832. {
  833.     COMPLEX *c;
  834.     long n;
  835.     VALUE tmp;
  836.  
  837.     if (v2->v_type != V_NUM)
  838.         error("Non-real shift value");
  839.      if (qisfrac(v2->v_num))
  840.         error("Non-integral shift value");
  841.     if (v1->v_type != V_OBJ) {
  842.         if (isbig(v2->v_num->num))
  843.             error("Very large shift value");
  844.         n = qtoi(v2->v_num);
  845.     }
  846.     if (rightshift)
  847.         n = -n;
  848.     switch (v1->v_type) {
  849.         case V_NUM:
  850.             vres->v_num = qshift(v1->v_num, n);
  851.             vres->v_type = V_NUM;
  852.             return;
  853.         case V_COM:
  854.             c = cshift(v1->v_com, n);
  855.             if (!cisreal(c)) {
  856.                 vres->v_com = c;
  857.                 vres->v_type = V_COM;
  858.                 return;
  859.             }
  860.             vres->v_num = qlink(c->real);
  861.             vres->v_type = V_NUM;
  862.             comfree(c);
  863.             return;
  864.         case V_MAT:
  865.             vres->v_mat = matshift(v1->v_mat, n);
  866.             vres->v_type = V_MAT;
  867.             return;
  868.         case V_OBJ:
  869.             if (!rightshift) {
  870.                 *vres = objcall(OBJ_SHIFT, v1, v2);
  871.                 return;
  872.             }
  873.             tmp.v_num = qneg(v2->v_num);
  874.             tmp.v_type = V_NUM;
  875.             *vres = objcall(OBJ_SHIFT, v1, &tmp);
  876.             qfree(tmp.v_num);
  877.             return;
  878.         default:
  879.             error("Bad value for shifting");
  880.     }
  881. }
  882.  
  883.  
  884. /*
  885.  * Scale a value by a power of two.
  886.  * Result is placed in the indicated location.
  887.  */
  888. void
  889. scalevalue(v1, v2, vres)
  890.     VALUE *v1, *v2, *vres;
  891. {
  892.     long n;
  893.  
  894.     if (v2->v_type != V_NUM)
  895.         error("Non-real scaling factor");
  896.     if (qisfrac(v2->v_num))
  897.         error("Non-integral scaling factor");
  898.     if (v1->v_type != V_OBJ) {
  899.         if (isbig(v2->v_num->num))
  900.             error("Very large scaling factor");
  901.         n = qtoi(v2->v_num);
  902.     }
  903.     switch (v1->v_type) {
  904.         case V_NUM:
  905.             vres->v_num = qscale(v1->v_num, n);
  906.             vres->v_type = V_NUM;
  907.             return;
  908.         case V_COM:
  909.             vres->v_com = cscale(v1->v_com, n);
  910.             vres->v_type = V_NUM;
  911.             return;
  912.         case V_MAT:
  913.             vres->v_mat = matscale(v1->v_mat, n);
  914.             vres->v_type = V_MAT;
  915.             return;
  916.         case V_OBJ:
  917.             *vres = objcall(OBJ_SCALE, v1, v2);
  918.             return;
  919.         default:
  920.             error("Bad value for scaling");
  921.     }
  922. }
  923.  
  924.  
  925. /*
  926.  * Raise a value to an integral power.
  927.  * Result is placed in the indicated location.
  928.  */
  929. void
  930. powivalue(v1, v2, vres)
  931.     VALUE *v1, *v2, *vres;
  932. {
  933.     NUMBER *q;
  934.     COMPLEX *c;
  935.  
  936.     vres->v_type = V_NULL;
  937.     if (v2->v_type != V_NUM)
  938.         error("Raising value to non-real power");
  939.     q = v2->v_num;
  940.     if (qisfrac(q))
  941.         error("Raising value to non-integral power");
  942.     switch (v1->v_type) {
  943.         case V_NUM:
  944.             vres->v_num = qpowi(v1->v_num, q);
  945.             vres->v_type = V_NUM;
  946.             return;
  947.         case V_COM:
  948.             vres->v_com = cpowi(v1->v_com, q);
  949.             vres->v_type = V_COM;
  950.             c = vres->v_com;
  951.             if (!cisreal(c))
  952.                 return;
  953.             vres->v_num = qlink(c->real);
  954.             vres->v_type = V_NUM;
  955.             comfree(c);
  956.             return;
  957.         case V_MAT:
  958.             vres->v_mat = matpowi(v1->v_mat, q);
  959.             vres->v_type = V_MAT;
  960.             return;
  961.         case V_OBJ:
  962.             *vres = objcall(OBJ_POW, v1, v2);
  963.             return;
  964.         default:
  965.             error("Illegal value for raising to integer power");
  966.     }
  967. }
  968.  
  969.  
  970. /*
  971.  * Raise one value to another value's power, within the specified error.
  972.  * Result is placed in the indicated location.
  973.  */
  974. void
  975. powervalue(v1, v2, v3, vres)
  976.     VALUE *v1, *v2, *v3, *vres;
  977. {
  978.     NUMBER *epsilon;
  979.     COMPLEX *c, ctmp;
  980.  
  981.     vres->v_type = V_NULL;
  982.     if (v3->v_type != V_NUM)
  983.         error("Non-real epsilon value for power");
  984.     epsilon = v3->v_num;
  985.     if (qisneg(epsilon) || qiszero(epsilon))
  986.         error("Non-positive epsilon value for power");
  987.     switch (TWOVAL(v1->v_type, v2->v_type)) {
  988.         case TWOVAL(V_NUM, V_NUM):
  989.             vres->v_num = qpower(v1->v_num, v2->v_num, epsilon);
  990.             vres->v_type = V_NUM;
  991.             return;
  992.         case TWOVAL(V_NUM, V_COM):
  993.             ctmp.real = v1->v_num;
  994.             ctmp.imag = &_qzero_;
  995.             vres->v_com = cpower(&ctmp, v2->v_com, epsilon);
  996.             break;
  997.         case TWOVAL(V_COM, V_NUM):
  998.             ctmp.real = v2->v_num;
  999.             ctmp.imag = &_qzero_;
  1000.             vres->v_com = cpower(v1->v_com, &ctmp, epsilon);
  1001.             break;
  1002.         case TWOVAL(V_COM, V_COM):
  1003.             vres->v_com = cpower(v1->v_com, v2->v_com, epsilon);
  1004.             break;
  1005.         default:
  1006.             error("Illegal value for raising to power");
  1007.     }
  1008.     /*
  1009.      * Here for any complex result.
  1010.      */
  1011.     vres->v_type = V_COM;
  1012.     c = vres->v_com;
  1013.     if (!cisreal(c))
  1014.         return;
  1015.     vres->v_num = qlink(c->real);
  1016.     vres->v_type = V_NUM;
  1017.     comfree(c);
  1018. }
  1019.  
  1020.  
  1021. /*
  1022.  * Divide one arbitrary value by another one.
  1023.  * Result is placed in the indicated location.
  1024.  */
  1025. void
  1026. divvalue(v1, v2, vres)
  1027.     VALUE *v1, *v2, *vres;
  1028. {
  1029.     COMPLEX *c;
  1030.     COMPLEX tmp;
  1031.     VALUE tmpval;
  1032.  
  1033.     vres->v_type = V_NULL;
  1034.     switch (TWOVAL(v1->v_type, v2->v_type)) {
  1035.         case TWOVAL(V_NUM, V_NUM):
  1036.             vres->v_num = qdiv(v1->v_num, v2->v_num);
  1037.             vres->v_type = V_NUM;
  1038.             return;
  1039.         case TWOVAL(V_COM, V_NUM):
  1040.             vres->v_com = cdivq(v1->v_com, v2->v_num);
  1041.             vres->v_type = V_COM;
  1042.             return;
  1043.         case TWOVAL(V_NUM, V_COM):
  1044.             if (qiszero(v1->v_num)) {
  1045.                 vres->v_num = qlink(&_qzero_);
  1046.                 vres->v_type = V_NUM;
  1047.                 return;
  1048.             }
  1049.             tmp.real = v1->v_num;
  1050.             tmp.imag = &_qzero_;
  1051.             vres->v_com = cdiv(&tmp, v2->v_com);
  1052.             vres->v_type = V_COM;
  1053.             return;
  1054.         case TWOVAL(V_COM, V_COM):
  1055.             vres->v_com = cdiv(v1->v_com, v2->v_com);
  1056.             vres->v_type = V_COM;
  1057.             c = vres->v_com;
  1058.             if (cisreal(c)) {
  1059.                 vres->v_num = qlink(c->real);
  1060.                 vres->v_type = V_NUM;
  1061.                 comfree(c);
  1062.             }
  1063.             return;
  1064.         case TWOVAL(V_MAT, V_NUM):
  1065.         case TWOVAL(V_MAT, V_COM):
  1066.             invertvalue(v2, &tmpval);
  1067.             vres->v_mat = matmulval(v1->v_mat, &tmpval);
  1068.             vres->v_type = V_MAT;
  1069.             freevalue(&tmpval);
  1070.             return;
  1071.         default:
  1072.             if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
  1073.                 error("Non-compatible values for divide");
  1074.             *vres = objcall(OBJ_DIV, v1, v2);
  1075.             return;
  1076.     }
  1077. }
  1078.  
  1079.  
  1080. /*
  1081.  * Divide one arbitrary value by another one keeping only the integer part.
  1082.  * Result is placed in the indicated location.
  1083.  */
  1084. void
  1085. quovalue(v1, v2, vres)
  1086.     VALUE *v1, *v2, *vres;
  1087. {
  1088.     COMPLEX *c;
  1089.  
  1090.     vres->v_type = V_NULL;
  1091.     switch (TWOVAL(v1->v_type, v2->v_type)) {
  1092.         case TWOVAL(V_NUM, V_NUM):
  1093.             vres->v_num = qquo(v1->v_num, v2->v_num);
  1094.             vres->v_type = V_NUM;
  1095.             return;
  1096.         case TWOVAL(V_COM, V_NUM):
  1097.             vres->v_com = cquoq(v1->v_com, v2->v_num);
  1098.             vres->v_type = V_COM;
  1099.             c = vres->v_com;
  1100.             if (cisreal(c)) {
  1101.                 vres->v_num = qlink(c->real);
  1102.                 vres->v_type = V_NUM;
  1103.                 comfree(c);
  1104.             }
  1105.             return;
  1106.         case TWOVAL(V_MAT, V_NUM):
  1107.         case TWOVAL(V_MAT, V_COM):
  1108.             vres->v_mat = matquoval(v1->v_mat, v2);
  1109.             vres->v_type = V_MAT;
  1110.             return;
  1111.         default:
  1112.             if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
  1113.                 error("Non-compatible values for quotient");
  1114.             *vres = objcall(OBJ_QUO, v1, v2);
  1115.             return;
  1116.     }
  1117. }
  1118.  
  1119.  
  1120. /*
  1121.  * Divide one arbitrary value by another one keeping only the remainder.
  1122.  * Result is placed in the indicated location.
  1123.  */
  1124. void
  1125. modvalue(v1, v2, vres)
  1126.     VALUE *v1, *v2, *vres;
  1127. {
  1128.     COMPLEX *c;
  1129.  
  1130.     vres->v_type = V_NULL;
  1131.     switch (TWOVAL(v1->v_type, v2->v_type)) {
  1132.         case TWOVAL(V_NUM, V_NUM):
  1133.             vres->v_num = qmod(v1->v_num, v2->v_num);
  1134.             vres->v_type = V_NUM;
  1135.             return;
  1136.         case TWOVAL(V_COM, V_NUM):
  1137.             vres->v_com = cmodq(v1->v_com, v2->v_num);
  1138.             vres->v_type = V_COM;
  1139.             c = vres->v_com;
  1140.             if (cisreal(c)) {
  1141.                 vres->v_num = qlink(c->real);
  1142.                 vres->v_type = V_NUM;
  1143.                 comfree(c);
  1144.             }
  1145.             return;
  1146.         case TWOVAL(V_MAT, V_NUM):
  1147.         case TWOVAL(V_MAT, V_COM):
  1148.             vres->v_mat = matmodval(v1->v_mat, v2);
  1149.             vres->v_type = V_MAT;
  1150.             return;
  1151.         default:
  1152.             if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
  1153.                 error("Non-compatible values for mod");
  1154.             *vres = objcall(OBJ_MOD, v1, v2);
  1155.             return;
  1156.     }
  1157. }
  1158.  
  1159.  
  1160. /*
  1161.  * Test an arbitrary value to see if it is equal to "zero".
  1162.  * The definition of zero varies depending on the value type.  For example,
  1163.  * the null string is "zero", and a matrix with zero values is "zero".
  1164.  * Returns TRUE if value is not equal to zero.
  1165.  */
  1166. BOOL
  1167. testvalue(vp)
  1168.     VALUE *vp;
  1169. {
  1170.     VALUE val;
  1171.  
  1172.     switch (vp->v_type) {
  1173.         case V_NUM:
  1174.             return !qiszero(vp->v_num);
  1175.         case V_COM:
  1176.             return !ciszero(vp->v_com);
  1177.         case V_STR:
  1178.             return (vp->v_str[0] != '\0');
  1179.         case V_MAT:
  1180.             return mattest(vp->v_mat);
  1181.         case V_LIST:
  1182.             return (vp->v_list->l_count != 0);
  1183.         case V_FILE:
  1184.             return validid(vp->v_file);
  1185.         case V_NULL:
  1186.             return FALSE;
  1187.         case V_OBJ:
  1188.             val = objcall(OBJ_TEST, vp);
  1189.             return (val.v_int != 0);
  1190.         default:
  1191.             return TRUE;
  1192.     }
  1193. }
  1194.  
  1195.  
  1196. /*
  1197.  * Compare two values for equality.
  1198.  * Returns TRUE if the two values differ.
  1199.  */
  1200. BOOL
  1201. comparevalue(v1, v2)
  1202.     VALUE *v1, *v2;
  1203. {
  1204.     int r;
  1205.     VALUE val;
  1206.  
  1207.     if ((v1->v_type == V_OBJ) || (v2->v_type == V_OBJ)) {
  1208.         val = objcall(OBJ_CMP, v1, v2);
  1209.         return (val.v_int != 0);
  1210.     }
  1211.     if (v1 == v2)
  1212.         return FALSE;
  1213.     if (v1->v_type != v2->v_type)
  1214.         return TRUE;
  1215.     switch (v1->v_type) {
  1216.         case V_NUM:
  1217.             r = qcmp(v1->v_num, v2->v_num);
  1218.             break;
  1219.         case V_COM:
  1220.             r = ccmp(v1->v_com, v2->v_com);
  1221.             break;
  1222.         case V_STR:
  1223.             r = ((v1->v_str != v2->v_str) &&
  1224.                 ((v1->v_str[0] - v2->v_str[0]) ||
  1225.                 strcmp(v1->v_str, v2->v_str)));
  1226.             break;
  1227.         case V_MAT:
  1228.             r = matcmp(v1->v_mat, v2->v_mat);
  1229.             break;
  1230.         case V_LIST:
  1231.             r = listcmp(v1->v_list, v2->v_list);
  1232.             break;
  1233.         case V_NULL:
  1234.             r = FALSE;
  1235.             break;
  1236.         case V_FILE:
  1237.             r = (v1->v_file != v2->v_file);
  1238.             break;
  1239.         default:
  1240.             error("Illegal values for comparevalue");
  1241.     }
  1242.     return (r != 0);
  1243. }
  1244.  
  1245.  
  1246. /*
  1247.  * Compare two values for their relative values.
  1248.  * Returns minus one if the first value is less than the second one,
  1249.  * one if the first value is greater than the second one, and
  1250.  * zero if they are equal.
  1251.  */
  1252. FLAG
  1253. relvalue(v1, v2)
  1254.     VALUE *v1, *v2;
  1255. {
  1256.     int r;
  1257.     VALUE val;
  1258.  
  1259.     if ((v1->v_type == V_OBJ) || (v2->v_type == V_OBJ)) {
  1260.         val = objcall(OBJ_REL, v1, v2);
  1261.         return val.v_int;
  1262.     }
  1263.     if (v1 == v2)
  1264.         return 0;
  1265.     if (v1->v_type != v2->v_type)
  1266.         error("Relative comparison of differing types");
  1267.     switch (v1->v_type) {
  1268.         case V_NUM:
  1269.             r = qrel(v1->v_num, v2->v_num);
  1270.             break;
  1271.         case V_STR:
  1272.             r = strcmp(v1->v_str, v2->v_str);
  1273.             break;
  1274.         case V_NULL:
  1275.             r = 0;
  1276.             break;
  1277.         default:
  1278.             error("Illegal value for relative comparison");
  1279.     }
  1280.     if (r < 0)
  1281.         return -1;
  1282.     return (r != 0);
  1283. }
  1284.  
  1285.  
  1286. /*
  1287.  * Print the value of a descriptor in one of several formats.
  1288.  * If flags contains PRINT_SHORT, then elements of arrays and lists
  1289.  * will not be printed.  If flags contains PRINT_UNAMBIG, then quotes
  1290.  * are placed around strings and the null value is explicitly printed.
  1291.  */
  1292. void
  1293. printvalue(vp, flags)
  1294.     VALUE *vp;
  1295. {
  1296.     switch (vp->v_type) {
  1297.         case V_NUM:
  1298.             qprintnum(vp->v_num, MODE_DEFAULT);
  1299.             break;
  1300.         case V_COM:
  1301.             comprint(vp->v_com);
  1302.             break;
  1303.         case V_STR:
  1304.             if (flags & PRINT_UNAMBIG)
  1305.                 math_chr('\"');
  1306.             math_str(vp->v_str);
  1307.             if (flags & PRINT_UNAMBIG)
  1308.                 math_chr('\"');
  1309.             break;
  1310.         case V_NULL:
  1311.             if (flags & PRINT_UNAMBIG)
  1312.                 math_str("NULL");
  1313.             break;
  1314.         case V_OBJ:
  1315.             (void) objcall(OBJ_PRINT, vp);
  1316.             break;
  1317.         case V_LIST:
  1318.             listprint(vp->v_list,
  1319.                 ((flags & PRINT_SHORT) ? 0L : maxprint));
  1320.             break;
  1321.         case V_MAT:
  1322.             matprint(vp->v_mat,
  1323.                 ((flags & PRINT_SHORT) ? 0L : maxprint));
  1324.             break;
  1325.         case V_FILE:
  1326.             printid(vp->v_file, flags);
  1327.             break;
  1328.         default:
  1329.             error("Printing unknown value");
  1330.     }
  1331. }
  1332.  
  1333. /* END CODE */
  1334.